home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / schemeMode.tcl < prev    next >
Encoding:
Text File  |  1998-12-08  |  5.6 KB  |  136 lines  |  [TEXT/ALFA]
  1.  
  2. alpha::mode Scm 1.0 dummyScm {*.scm} {electricTab}
  3.  
  4. #================================================================================
  5. # Scheme mode definition !  oleg@ponder.csci.unt.edu (Oleg Kiselyov)
  6. #
  7. # $Id: SchemeMode.tcl,v 1.3 1996/07/03 14:19:49 oleg Exp oleg $
  8. #================================================================================
  9.  
  10. newPref v leftFillColumn {2} Scm
  11. newPref v prefixString {;; } Scm 
  12. newPref v wordBreak {[^\(\) \t\r\n]+} Scm
  13. newPref f wordWrap {0} Scm
  14. newPref v funcExpr {^[\(]define.*$} Scm
  15.  
  16. newPref v wordBreakPreface {[\(\) \t\r\n]} Scm
  17.  
  18. newPref f autoMark 0 Scm
  19.  
  20. set scmCommentRegexp    {;.*$}
  21. set scmPreRegexp                {^\#[\t ]*[a-z]*}
  22. set schemeKeyWords              {
  23.     declare define define-macro lambda let let* letrec begin cond case do else
  24.     delay and or if set! #t #f
  25.     not eqv? eq? equal? pair? cons car cdr set-car! set-cdr!
  26.     caar cadr cdar cddr null? list? list length
  27.     append reverse list-ref memq memv member assq assv assoc
  28.     = < > <= >= zero? positive? negative? odd?
  29.     even? + * - / abs
  30.     exact->inexact inexact->exact number->string
  31.     string->number char? 
  32.     string string-length string-ref string-set! string=?
  33.     substring string-append vector?
  34.     make-vector vector vector-length vector-ref vector-set! procedure?
  35.     apply map for-each call-with-current-continuation
  36.     eof-object? read-char peek-char
  37.         }
  38. #regModeKeywords -e {;} -c cyan -k blue Scm $schemeKeyWords -i ")" -i "("  -i "," -i "." -I red
  39. regModeKeywords -e {;} -c cyan -k blue -s green Scm $schemeKeyWords
  40.  
  41.  
  42. #================================================================================
  43.  
  44. proc dummyScm {} {}
  45.  
  46. proc Scm::MarkFile {} {
  47.   set pat1 {^[ \t]*[\(][#a-zA-z]*(define|define-[a-zA-Z]+) +[\(]*([^\(\) \t\r\n]+)}
  48.   set end [maxPos]
  49.   set pos 0
  50.   set l {}
  51.   while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat1 $pos} mtch]} {
  52.     regexp -nocase $pat1 [eval getText $mtch] allofit defunname name
  53.     set start [lindex $mtch 0]
  54.     set end [nextLineStart $start]
  55.     set pos $end
  56.     set inds($name) [lineStart [expr $start - 1]]
  57.   }
  58.  
  59.   if {[info exists inds]} {
  60.     foreach f [lsort -ignore [array names inds]] {
  61.       set next [nextLineStart $inds($f)]
  62.       setNamedMark $f $inds($f) $next $next
  63.     }
  64.   }
  65. }
  66.  
  67. #================================================================================
  68. #                                       Indenting a line of a Scheme code
  69. #
  70. # The idea is simple: the indent of a new line is the same as the indent of the
  71. # previous non-empty non-comment-only line *plus* the paren balance of that
  72. # line times two
  73. # That is, if the last code line was paren balanced, the next line would have
  74. # the same indent. If the prev line opened an expression but didn't close it,
  75. # the new line would be indented further
  76. #
  77. # See indentLine.tcl for more details
  78.  
  79. proc Scm::indentLine {} {
  80.         set beg [lineStart [getPos]]
  81.         set end [nextLineStart [getPos]]
  82.  
  83.         # Find last previous non-comment line and get its leading whitespace
  84.         set pos $beg
  85.         set lst [search -s -f 0 -r 1 -i 0 {^[ \t]*[^ ;\t\r\n]} [expr $pos-1]]   
  86.         set line [getText [lindex $lst 0] [expr [nextLineStart [lindex $lst 0]] - 1]]
  87.         set lwhite [getText [lindex $lst 0] [expr [lindex $lst 1] - 1]]
  88.  
  89.         # computing the balance of parentheses within the 'line'
  90.         # This appears to be utterly elementary. One has to keep in mind however
  91.         # that parentheses might appear in comments and/or quoted strings,
  92.         # in which case they shouldn't count. Although it's easy to detect a
  93.         # Scheme comment by a semicolon, a semicolon can also appear within
  94.         # a quoted string. Note that a double quote isn't that sure a sign of
  95.         # a quoted string: the double quote may be escaped. And the backslash
  96.         # can be escaped in turn... Thus we face a full-blown problem of parsing
  97.         # a string according to a context-free grammar.
  98.         # We note however that a TCL interpretor does similar kind of parsing
  99.         # all the time. So, we can piggy-back on it and have it decide what is
  100.         # the quoted string and when a semicolon really starts a comment. To this
  101.         # end, we replace all non-essential characters from the 'line' with spaces,
  102.         # separate all parens with spaces (so each paren would register as a
  103.         # separate token with the TCL interpretor), replace a semicolon with
  104.         # an opening brace (which, if unescaped and unquoted, acts as some kind
  105.         # of "comment", that is, shields all symbols that follows).
  106.         # After that, we get TCL interpretor to convert thus prepared 'line'
  107.         # into a list, and simply count the balance of '(' and ')' tokens.
  108.         
  109.         regsub -all -nocase {[^ ();\"\\]} $line { } line1
  110.         regsub -all {;} $line1 "\{" line
  111.         regsub -all {[()]} $line { \0 } line1
  112.         set line_list [eval "list $line1 \}"]
  113.         #alertnote ">$line_list<"
  114.         set balance 0
  115.         foreach i $line_list { switch $i ( {incr balance} ) {incr balance -1} }
  116.         #alertnote "balance $balance, lwhite [string length $lwhite]"
  117.         if {$balance < 0} {
  118.                 set lwhite [string range $lwhite 0 [expr [string length $lwhite] + 2 * $balance - 1]]
  119.         } else {
  120.                 append lwhite [string range "              " 1 [expr 2 * $balance]]
  121.         }
  122.         #alertnote "new lwhite [string length $lwhite]"
  123.                         
  124.         set text [getText $beg [nextLineStart $beg]]
  125.         regexp {^[ \t]*} $text white
  126.         set len [string length $white]
  127.         
  128.         if {$white != $lwhite} {
  129.                 replaceText $beg [expr $beg + $len] $lwhite
  130.         }
  131.         goto [expr $beg + [string length $lwhite]]
  132.         return
  133.         
  134. }
  135.  
  136.